home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / hash.d < prev    next >
Encoding:
Text File  |  1994-05-07  |  10.8 KB  |  474 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19. */
  20.  
  21. #include "include.h"
  22. #include "mp.h"
  23.  
  24. object Seq;
  25. object Seql;
  26. object Sequal;
  27.  
  28. object Ksize;
  29. object Krehash_size;
  30. object Krehash_threshold;
  31.  
  32.  
  33. unsigned int
  34. hash_eql(x)
  35. object x;
  36. {
  37.     unsigned int h = 0;
  38.  
  39.     switch (type_of(x)) {
  40.     case t_fixnum:
  41.         return(fix(x));
  42.  
  43.     case t_bignum:
  44.         { GEN u = MP(x);
  45.           int l = lg(u) - 2;
  46.           u += 2;
  47.           h += l;
  48.           if (l > 5) l = 5;
  49.           while (-- l >= 0)
  50.             { h += *u++;}
  51.           return(h);
  52.         }
  53.  
  54.     case t_ratio:
  55.            return(hash_eql(x->rat.rat_num) + hash_eql(x->rat.rat_den));
  56.  
  57.     case t_shortfloat:
  58.         return(*((int *) &(sf(x))));
  59.  
  60.     case t_longfloat:
  61.         {int *y = (int *) &lf(x);
  62.         return( *y + *(y+1));}
  63.  
  64.     case t_complex:
  65.         return(hash_eql(x->cmp.cmp_real) + hash_eql(x->cmp.cmp_imag));
  66.  
  67.     case t_character:
  68.         return(char_code(x));
  69.  
  70.     default:
  71.         return((unsigned int)x / 4);
  72.     }
  73. }
  74.  
  75. unsigned int
  76. hash_equal(x,depth)
  77. object x;
  78. int depth;
  79. {
  80.     unsigned int h = 0;
  81.     int i;
  82.     char *s;
  83.  
  84.     cs_check(x);
  85.  
  86. BEGIN:
  87.     if (depth++ >3) return h;
  88.     switch (type_of(x)) {
  89.     case t_cons:
  90.         h += hash_equal(x->c.c_car,depth);
  91.         x = x->c.c_cdr;
  92.         goto BEGIN;
  93.  
  94.     case t_string:
  95.         for (i = x->st.st_fillp, s = x->st.st_self;  i > 0;  --i, s++)
  96.             h += (*s & 0377)*12345 + 1;
  97.         return(h);
  98.     case t_symbol:
  99.         /* case t_string could share this code--wfs */
  100.         {int len=x->st.st_fillp;
  101.          s=x->st.st_self;
  102.          switch(len) {
  103.          case 0: break;
  104.          default:
  105.          case 4: h+= s[--len] << 24;
  106.          case 3: h+= s[--len]<< 16;
  107.          case 2: h+= s[1] << 8;
  108.          case 1: h+= s[0] ;
  109.            
  110.            
  111.          }
  112.          return(h);
  113.            }
  114.            
  115.         case t_package:  return h;
  116.     case t_bitvector:
  117.         {static char ar[10];
  118.      i = x->bv.bv_fillp;
  119.      h = h + i;
  120.      i = i/8;
  121.      if (i > 10) i= 10;
  122.      s = x->bv.bv_self;
  123.      if (x->bv.bv_offset)
  124.        {int k,j;
  125.         int e = i;
  126.         s = ar;
  127.         /* 8 should be CHAR_SIZE but this needs to be changed
  128.            everywhere .. */
  129.         e = e * 8;
  130.         bzero(ar,sizeof(ar));
  131.         for (k = x->bv.bv_offset, j = 0;  k < e;  k++, j++)
  132.           if (x->bv.bv_self[k/8]&(0200>>k%8))
  133.         ar[j/8]  |= 0200>>j%8;
  134.       }
  135.      for (;  i > 0;  --i, s++)
  136.        h += (*s & 0377)*12345 + 1;
  137.  
  138.      return(h);
  139.        }
  140.     case t_pathname:
  141.         h += hash_equal(x->pn.pn_host,depth);
  142.         h += hash_equal(x->pn.pn_device,depth);
  143.         h += hash_equal(x->pn.pn_directory,depth);
  144.         h += hash_equal(x->pn.pn_name,depth);
  145.         h += hash_equal(x->pn.pn_type,depth);
  146.         h += hash_equal(x->pn.pn_version,depth);
  147.         return(h);
  148. /*  CLTLII says don't descend into structures
  149.     case t_structure:
  150.         {unsigned char *s_type;
  151.          struct s_data *def;
  152.          def=S_DATA(x->str.str_def);
  153.          s_type= & SLOT_TYPE(x->str.str_def,0);
  154.          h += hash_equal(def->name,depth);
  155.          for (i = 0;  i < def->length;  i++)
  156.            if (s_type[i]==0)
  157.              h += hash_equal(x->str.str_self[i],depth);
  158.            else
  159.              h += ((int)x->str.str_self[i]) + depth++;
  160.          return(h);}
  161. */
  162.  
  163.     default:
  164.         return(h + hash_eql(x));
  165.     }
  166. }
  167.         
  168. struct htent *
  169. gethash(key, hashtable)
  170. object key;
  171. object hashtable;
  172. {
  173.     enum httest htest;
  174.     int hsize;
  175.     struct htent *e;
  176.     object hkey;
  177.     int i, j = -1, k; /* k added by chou */
  178.     bool b;
  179.  
  180.     htest = (enum httest)hashtable->ht.ht_test;
  181.     hsize = hashtable->ht.ht_size;
  182.     if (htest == htt_eq)
  183.         i = (int)key / 4;
  184.     else if (htest == htt_eql)
  185.         i = hash_eql(key);
  186.     else if (htest == htt_equal)
  187.         i = hash_equal(key,0);
  188.     i &= 0x7fffffff;
  189.     for (i %= hsize, k = 0; k < hsize;  i = (i + 1) % hsize, k++) { /* k added by chou */
  190.         e = &hashtable->ht.ht_self[i];
  191.         hkey = e->hte_key;
  192.         if (hkey == OBJNULL) {
  193.             if (e->hte_value == OBJNULL)
  194.                 if (j < 0)
  195.                     return(e);
  196.                 else
  197.                     return(&hashtable->ht.ht_self[j]);
  198.             else
  199.                 if (j < 0)
  200.                     j = i;
  201.                 else if (j==i)
  202.                   /* this was never returning --wfs
  203.                      but looping around with j=0 */
  204.                   return(e) 
  205.                     ;
  206.             continue;
  207.         }
  208.         if (htest == htt_eq)
  209.                 b = key == hkey;
  210.         else if (htest == htt_eql)
  211.             b = eql(key, hkey);
  212.         else if (htest == htt_equal)
  213.             b = equal(key, hkey);
  214.         if (b)
  215.             return(&hashtable->ht.ht_self[i]);
  216.     }
  217.     return(&hashtable->ht.ht_self[j]);    /* added by chou */
  218. }
  219.  
  220. sethash(key, hashtable, value)
  221. object key, hashtable, value;
  222. {
  223.     int i;
  224.     bool over;
  225.     struct htent *e;
  226.     
  227.     i = hashtable->ht.ht_nent + 1;
  228.     if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum)
  229.         over = i >= fix(hashtable->ht.ht_rhthresh);
  230.     else if (type_of(hashtable->ht.ht_rhthresh) == t_shortfloat)
  231.         over =
  232.         i >= hashtable->ht.ht_size * sf(hashtable->ht.ht_rhthresh);
  233.     else if (type_of(hashtable->ht.ht_rhthresh) == t_longfloat)
  234.         over =
  235.         i >= hashtable->ht.ht_size * lf(hashtable->ht.ht_rhthresh);
  236.     if (over)
  237.         extend_hashtable(hashtable);
  238.     e = gethash(key, hashtable);
  239.     if (e->hte_key == OBJNULL)
  240.         hashtable->ht.ht_nent++;
  241.     e->hte_key = key;
  242.     e->hte_value = value;
  243. }
  244.     
  245. extend_hashtable(hashtable)
  246. object hashtable;
  247. {
  248.     object old;
  249.     int new_size, i;
  250.  
  251.     if (type_of(hashtable->ht.ht_rhsize) == t_fixnum)
  252.         new_size = 
  253.         hashtable->ht.ht_size + fix(hashtable->ht.ht_rhsize);
  254.     else if (type_of(hashtable->ht.ht_rhsize) == t_shortfloat)
  255.         new_size = 
  256.         hashtable->ht.ht_size * sf(hashtable->ht.ht_rhsize);
  257.     else if (type_of(hashtable->ht.ht_rhsize) == t_longfloat)
  258.         new_size = 
  259.         hashtable->ht.ht_size * lf(hashtable->ht.ht_rhsize);
  260.     old = alloc_object(t_hashtable);
  261.     old->ht = hashtable->ht;
  262.     vs_push(old);
  263.     hashtable->ht.ht_self = NULL;
  264.     hashtable->ht.ht_size = new_size;
  265.     if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum)
  266.         hashtable->ht.ht_rhthresh =
  267.         make_fixnum(fix(hashtable->ht.ht_rhthresh) +
  268.                 (new_size - old->ht.ht_size));
  269.     hashtable->ht.ht_self =
  270.     (struct htent *)alloc_relblock(new_size * sizeof(struct htent));
  271.     for (i = 0;  i < new_size;  i++) {
  272.         hashtable->ht.ht_self[i].hte_key = OBJNULL;
  273.         hashtable->ht.ht_self[i].hte_value = OBJNULL;
  274.     }
  275.     for (i = 0;  i < old->ht.ht_size;  i++) {
  276.         if (old->ht.ht_self[i].hte_key != OBJNULL)
  277.             sethash(old->ht.ht_self[i].hte_key,
  278.                 hashtable,
  279.                 old->ht.ht_self[i].hte_value);
  280.     }
  281.     hashtable->ht.ht_nent = old->ht.ht_nent;
  282.     vs_pop;
  283. }
  284.  
  285.  
  286. @(defun make_hash_table (&key (test Seql)
  287.                   (size `make_fixnum(1024)`)
  288.                   (rehash_size
  289.                    `make_shortfloat((shortfloat)1.5)`)
  290.                   (rehash_threshold
  291.                    `make_shortfloat((shortfloat)0.7)`)
  292.              &aux h)
  293.     enum httest htt;
  294.     int i;
  295. @
  296.     if (test == Seq || test == Seq->s.s_gfdef)
  297.         htt = htt_eq;
  298.     else if (test == Seql || test == Seql->s.s_gfdef)
  299.         htt = htt_eql;
  300.     else if (test == Sequal || test == Sequal->s.s_gfdef)
  301.         htt = htt_equal;
  302.     else
  303.         FEerror("~S is an illegal hash-table test function.",
  304.             1, test);
  305.       if (type_of(size) != t_fixnum || 0 < fix(size))
  306.         ;
  307.     else
  308.         FEerror("~S is an illegal hash-table size.", 1, size);
  309.     if (type_of(rehash_size) == t_fixnum && 0 < fix(rehash_size) ||
  310.         type_of(rehash_size) == t_shortfloat && 1.0 < sf(rehash_size) ||
  311.         type_of(rehash_size) == t_longfloat && 1.0 < lf(rehash_size))
  312.         ;
  313.     else
  314.         FEerror("~S is an illegal hash-table rehash-size.",
  315.             1, rehash_size);
  316.     if (type_of(rehash_threshold) == t_fixnum &&
  317.         0 < fix(rehash_threshold) && fix(rehash_threshold) < fix(size) ||
  318.         type_of(rehash_threshold) == t_shortfloat &&
  319.         0.0 < sf(rehash_threshold) && sf(rehash_threshold) < 1.0 ||
  320.         type_of(rehash_threshold) == t_longfloat &&
  321.         0.0 < lf(rehash_threshold) && lf(rehash_threshold) < 1.0)
  322.         ;
  323.     else
  324.         FEerror("~S is an illegal hash-table rehash-threshold.",
  325.             1, rehash_threshold);
  326.     h = alloc_object(t_hashtable);
  327.     h->ht.ht_test = (short)htt;
  328.     h->ht.ht_size = fix(size);
  329.     h->ht.ht_rhsize = rehash_size;
  330.     h->ht.ht_rhthresh = rehash_threshold;
  331.         h->ht.ht_nent = 0;
  332.     h->ht.ht_self = NULL;
  333.     h->ht.ht_self = (struct htent *)
  334.     alloc_relblock(fix(size) * sizeof(struct htent));
  335.     for(i = 0;  i < fix(size);  i++) {
  336.         h->ht.ht_self[i].hte_key = OBJNULL;
  337.         h->ht.ht_self[i].hte_value = OBJNULL;
  338.     }
  339.     @(return h)
  340. @)
  341.  
  342. Lhash_table_p()
  343. {
  344.     check_arg(1);
  345.  
  346.     if(type_of(vs_base[0]) == t_hashtable)
  347.         vs_base[0] = Ct;
  348.     else   
  349.         vs_base[0] = Cnil;
  350. }
  351.  
  352. Lgethash()
  353. {
  354.     int narg;
  355.     struct htent *e;
  356.     
  357.     narg = vs_top - vs_base;
  358.     if (narg < 2)
  359.         too_few_arguments();
  360.     else if (narg == 2)
  361.         vs_push(Cnil);
  362.     else if (narg > 3)
  363.         too_many_arguments();
  364.     check_type_hash_table(&vs_base[1]);
  365.     e = gethash(vs_base[0], vs_base[1]);
  366.     if (e->hte_key != OBJNULL) {
  367.         vs_base[0] = e->hte_value;
  368.         vs_base[1] = Ct;
  369.     } else {
  370.         vs_base[0] = vs_base[2];
  371.         vs_base[1] = Cnil;
  372.     }
  373.     vs_pop;
  374. }
  375.  
  376. siLhash_set()
  377. {
  378.     check_arg(3);
  379.  
  380.     check_type_hash_table(&vs_base[1]);
  381.     sethash(vs_base[0], vs_base[1], vs_base[2]);
  382.     vs_base += 2;
  383. }
  384.     
  385. Lremhash()
  386. {
  387.     struct htent *e;
  388.  
  389.     check_arg(2);
  390.     check_type_hash_table(&vs_base[1]);
  391.     e = gethash(vs_base[0], vs_base[1]);
  392.     if (e->hte_key != OBJNULL) {
  393.         e->hte_key = OBJNULL;
  394.         e->hte_value = Cnil;
  395.         vs_base[1]->ht.ht_nent--;
  396.         vs_base[0] = Ct;
  397.     } else
  398.         vs_base[0] = Cnil;
  399.     vs_top = vs_base + 1;
  400. }
  401.  
  402. Lclrhash()
  403. {
  404.     int i;
  405.  
  406.     check_arg(1);
  407.     check_type_hash_table(&vs_base[0]);
  408.     for(i = 0; i < vs_base[0]->ht.ht_size; i++) {
  409.         vs_base[0]->ht.ht_self[i].hte_key = OBJNULL;
  410.         vs_base[0]->ht.ht_self[i].hte_value = OBJNULL;
  411.     }
  412.     vs_base[0]->ht.ht_nent = 0;
  413. }
  414.  
  415. Lhash_table_count()
  416. {
  417.     object z;
  418.  
  419.     check_arg(1);
  420.     check_type_hash_table(&vs_base[0]);
  421.     vs_base[0] = make_fixnum(vs_base[0]->ht.ht_nent);
  422. }
  423.  
  424.  
  425. Lsxhash()
  426. {
  427.     check_arg(1);
  428.  
  429.     vs_base[0] = make_fixnum(hash_equal(vs_base[0],0) & 0x7fffffff);
  430. }
  431.  
  432. Lmaphash()
  433. {
  434.     object *base = vs_base;
  435.         object hashtable;
  436.     int i;
  437.  
  438.     check_arg(2);
  439.     check_type_hash_table(&vs_base[1]);
  440.     hashtable = vs_base[1];
  441.     for (i = 0;  i < hashtable->ht.ht_size;  i++) {
  442.         if(hashtable->ht.ht_self[i].hte_key != OBJNULL)
  443.             ifuncall2(base[0],
  444.                   hashtable->ht.ht_self[i].hte_key,
  445.                   hashtable->ht.ht_self[i].hte_value);
  446.     }
  447.     vs_base[0] = Cnil;
  448.     vs_pop;
  449. }
  450.  
  451.  
  452. init_hash()
  453. {
  454.     Seq = make_ordinary("EQ");
  455.     Seql = make_ordinary("EQL");
  456.     Sequal = make_ordinary("EQUAL");
  457.     Ksize = make_keyword("SIZE");
  458.     Ktest = make_keyword("TEST");
  459.     Krehash_size = make_keyword("REHASH-SIZE");
  460.     Krehash_threshold = make_keyword("REHASH-THRESHOLD");
  461.     
  462.     make_function("MAKE-HASH-TABLE", Lmake_hash_table);
  463.     make_function("HASH-TABLE-P", Lhash_table_p);
  464.     make_function("GETHASH", Lgethash);
  465.     make_function("REMHASH", Lremhash);
  466.        make_function("MAPHASH", Lmaphash);
  467.     make_function("CLRHASH", Lclrhash);
  468.     make_function("HASH-TABLE-COUNT", Lhash_table_count);
  469.        make_function("SXHASH", Lsxhash);
  470.     make_si_sfun("HASH-EQUAL",hash_equal,ARGTYPE2(f_object,f_fixnum)
  471.                         | RESTYPE(f_fixnum));
  472.     make_si_function("HASH-SET", siLhash_set);
  473. }
  474.